home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / enumvar.bas < prev    next >
BASIC Source File  |  1997-06-14  |  5KB  |  124 lines
  1. Attribute VB_Name = "MEnumVariant"
  2. Option Explicit
  3.  
  4. ''' Flag must be in standard module so that there is only one copy of it
  5. Public fNotFirstTime As Boolean
  6.  
  7. '' These functions will be placed in the v-table and executed as the
  8. '' real methods of the IEnumVARIANT object. They must be in a standard
  9. '' module because there must be only one copy of them, and AddressOf
  10. '' only works on standard module procedures.
  11.  
  12. ' Replace IEnumVARIANT_Next
  13. Public Function BasNext(ByVal this As IVBEnumVARIANT, ByVal cv As Long, _
  14.                         av As Variant, ByVal pcvFetched As Long) As Long
  15.     ' this - Object pointer
  16.     ' cv - Count of variants requested for return
  17.     ' av - Array to hold the requested variants
  18.     ' pcvFetched - Pointer to number of variants actually returned
  19.                         
  20.     Dim vTmp As Variant, vEmpty As Variant
  21.     Dim pv As Long, cvFetched As Long, fFetched As Boolean
  22.     Dim i As Integer, vars As CEnumVariant
  23.     ' First hidden argument of an object method is the object pointer--known as
  24.     ' the this pointer in C++. Set this to be an object of our internal
  25.     ' enumeration class.
  26.     Set vars = this
  27.     On Error Resume Next
  28.     ' Get the address of the first variant in array
  29.     pv = VarPtr(av)
  30.     ' Iterate through each requested variant
  31.     For i = 1 To cv
  32.         ' Call the class method that raises a Next event--it returns
  33.         ' true if the next value is fetched
  34.         fFetched = vars.ClsNext(vTmp)
  35.         ' If failure or nothing fetched, we're done
  36.         If (Err) Or fFetched = False Then Exit For
  37.         ' Copy variant to current array position
  38.         CopyMemory ByVal pv, vTmp, 16
  39.         ' Empty work variant without destroying its object or string
  40.         CopyMemory vTmp, vEmpty, 16
  41.         ' Count the variant and point to the next one
  42.         cvFetched = cvFetched + 1
  43.         pv = pv + 16
  44.     Next
  45.     ' If error caused termination, undo what we did
  46.     If Err.Number Then
  47.         ' Iterate back, emptying the invalid fetched variants
  48.         For i = i To 1 Step -1
  49.             ' Copy variant to current array position
  50.             CopyMemory vTmp, ByVal pv, 16
  51.             ' Empty work variant, destroying any object or string
  52.             vTmp = Empty
  53.             ' Empty array variant without destroying any object or string
  54.             CopyMemory ByVal pv, vEmpty, 16
  55.             ' Point to previous array element
  56.             pv = pv - 16
  57.         Next
  58.         ' Convert error to COM format
  59.         BasNext = MapErr(Err)
  60.         ' Return 0 as the number fetched after error
  61.         If pcvFetched Then CopyMemory ByVal pcvFetched, ByVal 0&, 4
  62.     Else
  63.         ' If nothing fetched, break out of enumeration
  64.         If cvFetched = 0 Then BasNext = 1
  65.         ' Copy the actual number fetched to the pointer to fetched count
  66.         If pcvFetched Then CopyMemory ByVal pcvFetched, cvFetched, 4
  67.     End If
  68. End Function
  69.  
  70. ' Replace IEnumVARIANT_Skip
  71. Public Function BasSkip(ByVal this As IVBEnumVARIANT, _
  72.                         ByVal cv As Long) As Long
  73.     Dim vars As CEnumVariant, i As Long
  74.     Set vars = this
  75.     On Error Resume Next
  76.     ' Call the class method that raises a Skip event
  77.     vars.ClsSkip cv
  78.     BasSkip = MapErr(Err)
  79. End Function
  80.  
  81. ' Put the function address (callback) directly into the object v-table
  82. Public Function ReplaceVtableEntry(ByVal pObj As Long, _
  83.                                    ByVal iEntry As Integer, _
  84.                                    ByVal pFunc As Long) As Long
  85.     ' pObj - Pointer to object whose v-table will be modified
  86.     ' iEntry - Index of v-table entry to be modified
  87.     ' pFunc - Function pointer of new v-table method
  88.                             
  89.     Dim pFuncOld As Long, pVTableHead As Long
  90.     Dim pFuncTmp As Long, lOldProtect As Long
  91.     
  92.     ' Object pointer contains a pointer to v-table--copy it to temporary
  93.     CopyMemory pVTableHead, ByVal pObj, 4       ' pVTableHead = *pObj;
  94.     ' Calculate pointer to specified entry
  95.     pFuncTmp = pVTableHead + (iEntry - 1) * 4
  96.     ' Save address of previous method for return
  97.     CopyMemory pFuncOld, ByVal pFuncTmp, 4      ' pFuncOld = *pFuncTmp;
  98.     ' Ignore if they're already the same
  99.     If pFuncOld <> pFunc Then
  100.         ' Need to change page protection to write to code
  101.         VirtualProtect pFuncTmp, 4, PAGE_EXECUTE_READWRITE, lOldProtect
  102.         ' Write the new function address into the v-table
  103.         CopyMemory ByVal pFuncTmp, pFunc, 4     ' *pFuncTmp = pfunc;
  104.         ' Restore the previous page protection
  105.         VirtualProtect pFuncTmp, 4, lOldProtect, lOldProtect 'Optional
  106.     End If
  107.     ReplaceVtableEntry = pFuncOld
  108. End Function
  109.  
  110. Public Function MapErr(ByVal ErrNumber As Long) As Long
  111.     If ErrNumber Then
  112.         If (ErrNumber And &H80000000) Or (ErrNumber = 1) Then
  113.             'Error HRESULT already set
  114.             MapErr = ErrNumber
  115.         Else
  116.             'Map back to a basic error number
  117.             MapErr = &H800A0000 Or ErrNumber
  118.         End If
  119.     End If
  120. End Function
  121.  
  122.  
  123.  
  124.